home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / stringsLists.tcl < prev    next >
Encoding:
Text File  |  1999-05-24  |  15.8 KB  |  564 lines  |  [TEXT/ALFA]
  1. #
  2. # strings.tcl (Mark Nagata and Tom Scavo and Vince Darley)
  3. #
  4.  
  5. namespace eval quote {}
  6. namespace eval text {}
  7. ## 
  8.  # -------------------------------------------------------------------------
  9.  # 
  10.  # "quote::" --
  11.  # 
  12.  # Manipulate string so search and insertion procedures work as expected.
  13.  # These files have been both renamed and rewritten from the former
  14.  # 'quoteExpr' procs.  They fix a number of bugs, and make their purpose
  15.  # clear.  There were numerous examples throughout Alpha's Tcl code which
  16.  # used the wrong quote function under the old scheme.
  17.  # 
  18.  # quote::Find
  19.  # 
  20.  #     use this for 'glob' type searches.
  21.  #     
  22.  # quote::Regfind
  23.  # 
  24.  #  use this for regexp searches
  25.  #  
  26.  # quote::Insert
  27.  # 
  28.  #  Quotes any block of text captured from a window so it can be used as a 
  29.  #  Tcl string. e.g. 'set a [quote::Insert [getSelect]] ; eval insertText $a'
  30.  #  will work correctly.  Can be used to generate procedures on the fly,
  31.  #  especially to add to your prefs.tcl:
  32.  #   set a [quote::Insert [getSelect]]
  33.  #   addUserLine "proc foo \{\} \{ return \"$a\" \}"
  34.  # 
  35.  # quote::Regsub
  36.  # 
  37.  #  use this for the replacement expression.  A common usage might look
  38.  #  like this:
  39.  #   
  40.  #   regsub -all [quote::Regfind $from] [read $cid] [quote::Regsub $to] out
  41.  # -------------------------------------------------------------------------
  42.  ##
  43. proc quote::Find  str {
  44.     regsub -all {[][\|*+()]} $str {\\&} str
  45.     return $str
  46. }
  47.  
  48. proc quote::Regfind str {
  49.     regsub -all {[][\$?^|*+()\.\{\}\\]} $str {\\&} str
  50.     return $str
  51. }
  52.  
  53. proc quote::Insert str {
  54.     regsub -all {[][\$"\{\}]} $str {\\&} str
  55.     regsub -all "\[\r\n\]" $str "\\r" str
  56.     regsub -all "\t" $str "\\t" str
  57.     return $str
  58. }
  59.  
  60. # These procs have been modified to avoid substitutions in TeX commands 
  61. # starting with \n, \r and \t. The fix is based on replacing single \ by
  62. # double \\ in 'quote::Display' and replacing \(n|r|t) by their ascii
  63. # counterpart only if there is an odd number of \.
  64. proc quote::Display str {
  65.     regsub -all {\\} $str {\\\\} str
  66.     regsub -all "\r" $str "\\r" str
  67.     regsub -all "\n" $str "\\n" str
  68.     regsub -all "\t" $str "\\t" str
  69.     return $str
  70. }
  71.  
  72. proc quote::Undisplay str {
  73.     regsub -all {(^|[^\\]|(\\\\)+)\\r} $str "\\1\r" str
  74.     regsub -all {(^|[^\\]|(\\\\)+)\\n} $str "\\1\n" str
  75.     regsub -all {(^|[^\\]|(\\\\)+)\\t} $str "\\1\t" str
  76.     regsub -all {\\\\} $str {\\} str
  77.     return $str
  78. }
  79.  
  80. proc quote::Regsub str {
  81.     regsub -all {(\\|&)} $str {\\&} str
  82.     return $str
  83. }
  84.  
  85. ## 
  86.  # -------------------------------------------------------------------------
  87.  # 
  88.  # "quote::Prettify" --
  89.  # 
  90.  #  Since we're supposed to be a LaTeX editor, we handle symbols with
  91.  #  TeX in a bit differently
  92.  # -------------------------------------------------------------------------
  93.  ##
  94. proc quote::Prettify str {
  95.     set a [string toupper [string index $str 0]]
  96.     regsub -all {([^A-Z])([A-Z])} [string range $str 1 end] {\1 \2} b
  97.     regsub -all {((La|Bib|Oz) )?Te X} $a$b {\2TeX } a
  98.     regsub -all {::} $a {-} a
  99.     return $a
  100. }
  101. proc quote::Menuify str {
  102.     set a [string toupper [string index $str 0]]
  103.     regsub -all { *([A-Z])} [string range $str 1 end] { \1} b
  104.     append a $b
  105. }
  106. ## 
  107.  # -------------------------------------------------------------------------
  108.  # 
  109.  # "quote::WhitespaceReg" --
  110.  # 
  111.  #  Quote a string so you can search for it ignoring all problems with
  112.  #  whitespace: all sequences of space/tab/cr are treated alike.
  113.  # -------------------------------------------------------------------------
  114.  ##
  115. proc quote::WhitespaceReg { str } { 
  116.     regsub -all "\[ \t\r\n\]+" $str {[ \t\r\n]+} str
  117.     return $str
  118. }
  119.  
  120. ## 
  121.  # -------------------------------------------------------------------------
  122.  # 
  123.  # "lremove" --
  124.  # 
  125.  #  removes items from a list
  126.  #  
  127.  #  options are '-all' to remove all, and -glob, -exact or -regexp
  128.  #  for search type.  '-exact' is the default. '--' terminates options.
  129.  #  
  130.  #  lremove ?-opts? l args
  131.  #  
  132.  #  Note: if you want to remove all items of list 'b' from list 'a',
  133.  #  the following is incorrect: lremove $a $b, you must use
  134.  #  'eval lremove [list $a] $b', so that b is expanded.
  135.  #  
  136.  #  There is now a new option -l which treats the extra args as lists,
  137.  #  so you can do lremove -l $a $b if you want.
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. proc lremove {args} {
  141.     set opts(-all) 0
  142.     set type "-exact"
  143.     getOpts
  144.     set l [lindex $args 0]
  145.     if {[info exists opts(-glob)]} { set type "-glob" }
  146.     if {[info exists opts(-regexp)]} { set type "-regexp" }
  147.     if {[info exists opts(-l)]} { 
  148.     set args [join [lreplace $args 0 0] " "]
  149.     } else {
  150.     set args [lreplace $args 0 0]
  151.     }
  152.     foreach i $args {
  153.     if {[set ix [lsearch $type $l $i]] == -1} continue
  154.     set l [lreplace $l $ix $ix]
  155.     if {$opts(-all)} {
  156.         while {[set ix [lsearch $type $l $i]] != -1} {
  157.         set l [lreplace $l $ix $ix]
  158.         }
  159.     }
  160.     }
  161.     return $l
  162. }
  163.  
  164. ## 
  165.  # -------------------------------------------------------------------------
  166.  # 
  167.  # "getOpts" --
  168.  # 
  169.  #  Rudimentary option passing.  Uses upvar to get to the 'args' list of
  170.  #  the calling procedure and scans that.  Option information is stored
  171.  #  in the 'opts' array of the calling procedure.
  172.  #  
  173.  #  Options are assumed to be flags, unless they occur in the optional
  174.  #  parameter list.  Then they are variables which take a value; the
  175.  #  next item in the args list.  If an item is a pair, then the first
  176.  #  is the var name and the second the number of arguments to give it.
  177.  # -------------------------------------------------------------------------
  178.  ##
  179. proc getOpts {{take_value ""} {set "set"}} {
  180.     upvar args a
  181.     upvar opts o
  182.     while {[string match \-* [set arg [lindex $a 0]]]} {
  183.     set a [lreplace $a 0 0]
  184.     if {$arg == "--"} {
  185.         return
  186.     } else {
  187.         if {[set idx [lsearch -regexp $take_value \
  188.           "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  189.         set o($arg) 1
  190.         } else {
  191.         if {[llength [set the_arg [lindex $take_value $idx]]] == 1} {
  192.             $set o($arg) [lindex $a 0]
  193.             set a [lreplace $a 0 0]
  194.         } else {
  195.             set numargs [expr {[lindex $the_arg 1] -1}]
  196.             $set o($arg) [lrange $a 0 $numargs]
  197.             set a [lreplace $a 0 $numargs]
  198.         }
  199.         }
  200.     }
  201.     }
  202. }
  203.  
  204. ## 
  205.  # -------------------------------------------------------------------------
  206.  # 
  207.  # "ensureset" --
  208.  # 
  209.  #  Ensure the given variable is set, if it is unset, set it to the given
  210.  #  value.  This works with both variables and array elements, including
  211.  #  things which contain spaces etc.
  212.  # -------------------------------------------------------------------------
  213.  ##
  214. proc ensureset {v {val ""}} {
  215.     if {[uplevel [list info exists $v]]} { return [uplevel [list set $v]] }
  216.     return [uplevel [list set $v $val]]
  217. }
  218. ## 
  219.  # -------------------------------------------------------------------------
  220.  # 
  221.  # "lunion" --
  222.  # 
  223.  #  Basic use: make sure a given list variable contains each element 
  224.  #  of 'args'
  225.  #  
  226.  #  "llunion" --
  227.  #  
  228.  #  Advanced use: make sure a given list variable and index contains
  229.  #  an element whose i'th index matches the i'th index of one of 'args'.
  230.  #  In this case we call the proc with a list {var i} as first argument.
  231.  # -------------------------------------------------------------------------
  232.  ##
  233. proc lunion {var args} {
  234.     upvar $var a
  235.     if {![info exists a]} {
  236.     set a $args
  237.     return
  238.     } else {
  239.     foreach item $args {
  240.         if {[lsearch $a $item] == -1} {
  241.         lappend a $item
  242.         }
  243.     }
  244.     }
  245. }
  246.     
  247. proc llunion {var idx args} {
  248.     upvar $var a
  249.     if {![info exists a]} {
  250.     set a $args
  251.     return
  252.     } else {
  253.     foreach item $args {
  254.         set add 1
  255.         foreach i $a {
  256.         if {[lindex $i $idx] == [lindex $item $idx]} {
  257.             set add 0
  258.             break
  259.         }
  260.         }
  261.         if {$add} {
  262.         lappend a $item
  263.         }
  264.     }
  265.     }
  266. }
  267.  
  268. proc lunique {l} {
  269.     set lout ""
  270.     foreach f $l {
  271.     if {![info exists silly($f)]} {
  272.         set silly($f) 1
  273.         lappend lout $f
  274.     }
  275.     }
  276.     return $lout
  277. }
  278.             
  279. proc lreverse {l} {
  280.     if {[llength $l] > 1} {
  281.     set first [lindex $l 0]
  282.     set l [lreverse [lrange $l 1 end]]
  283.     lappend l $first
  284.     }
  285.     return $l
  286. }
  287.  
  288. proc lcontains {l e} {
  289.     upvar $l ll
  290.     if {[info exists ll] && [lsearch -exact $ll $e] != -1} {
  291.     return 1
  292.     } else {
  293.     return 0
  294.     }
  295. }
  296.  
  297. ## 
  298.  # -------------------------------------------------------------------------
  299.  # 
  300.  # "llindex" --
  301.  # 
  302.  #  Find the first index of a given list within another list.  
  303.  # -------------------------------------------------------------------------
  304.  ##
  305. proc llindex {l e args} {
  306.     upvar $l ll
  307.     if {![info exists ll]} { return -1 }
  308.     if {![llength $args]} {
  309.     return [lsearch -exact $ll $e]
  310.     } else {
  311.     set i 0
  312.     set len [llength $args]
  313.     while {$i < [llength $ll] - $len} {
  314.         if {[lindex $ll $i] == $e} {
  315.         set range [lrange $ll [expr {$i +1}] [expr {$i + $len}]]
  316.         for {set j 0} {$j < $len} {incr j} {
  317.             if {[lindex $args $j] != [lindex $range $j]} {
  318.             break
  319.             }
  320.         }
  321.         if {$j == $len} { return $i}
  322.         }
  323.         incr i
  324.     }
  325.     return -1
  326.     }
  327. }
  328.  
  329. # Returns a modified text string if the string $text is non-null, 
  330. # and the null string otherwise.  The argument 'operation' is a 
  331. # string directing 'doSuffixText' to either "insert" or "remove" 
  332. # $suffixString to/from each line of $text.
  333. proc doSuffixText {operation suffixString text} {
  334.     if {$text == ""} {return ""}
  335.     set suff [quote::Find $suffixString]
  336.     if {$operation == "insert"} {
  337.     set str ${suffixString}\r
  338.     regsub -all \r $text $str text
  339.     } elseif {$operation == "remove"} {
  340.     set str ${suff}\r
  341.     regsub -all -- $str $text \r text
  342.     }
  343.     return $text
  344. }
  345.  
  346. # Returns a modified text string if the string $text is non-null, 
  347. # and the null string otherwise.  The argument 'operation' is a 
  348. # string directing 'doPrefixText' to either "insert" or "remove" 
  349. # $prefixString to/from each line of $text.  See latexEngine.tcl
  350. # for an example.
  351. proc doPrefixText {operation prefixString text} {
  352.     set pref [quote::Find $prefixString]
  353.     if {$operation == "insert"} {
  354.     set trailChar ""
  355.     set textLen [string length $text]
  356.     if {$textLen && ([string index $text [expr {$textLen-1}]] == "\r")} {
  357.         set text [string range $text 0 [expr {$textLen-2}]]
  358.         set trailChar "\r"
  359.     }
  360.     set str \r$prefixString
  361.     regsub -all \r $text $str text
  362.     return $prefixString$text$trailChar
  363.     } elseif {$operation == "remove"} {
  364.     regsub -all \r$pref $text \r text
  365.     regsub ^$pref $text "" text
  366.     return $text
  367.     }
  368. }
  369.  
  370. proc text::british {v} {
  371.     uplevel "regsub -all -nocase {(Colo)r} \[set $v\] {\\1ur} $v"
  372. }
  373.  
  374. rename getAscii {}
  375. proc getAscii {} {
  376.     set c [lookAt [getPos]]
  377.     scan $c %c decVal
  378.     set asOctal [format %o $decVal]
  379.     set asHex   [format %x $decVal]
  380.     alertnote "saw a \"$c\", $decVal -decimal,\
  381.       \\$asOctal -octal, x$asHex -hex"
  382. }
  383.  
  384. # nabbed from html mode
  385. set text::_Ascii "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  386. append text::_Ascii "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  387. append text::_Ascii " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  388. append text::_Ascii "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  389. append text::_Ascii "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  390. append text::_Ascii "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  391. proc text::Ascii {char {num 0}} {
  392.     if {$char == ""} {return 0}
  393.     global text::_Ascii
  394.     if {$num} {
  395.     if {$char > 256 || $char < 1} { beep ; message "text::Ascii called with bad argument" }
  396.     return [string index ${text::_Ascii} [expr {$char - 1}]]
  397.     } else {
  398.     return [expr {1 + [string first $char ${text::_Ascii}]}]
  399.     }
  400. }
  401.  
  402. proc text::fromPstring {str} {
  403.     set len [text::Ascii [string index $str 0]]
  404.     return [string range $str 1 $len]
  405. }
  406.  
  407. # Useful for -command flag of 'lsort'.
  408. proc sortByTail {one two} {
  409.     string compare [file tail $one] [file tail $two]
  410. }
  411.  
  412.  
  413. namespace eval is {}
  414.  
  415. proc is::Hexadecimal {str} {
  416.     return [regexp {^[0-9a-fA-F]+$} [string trim $str]]
  417. }
  418.  
  419. proc is::Numeric {str} {
  420.     return [expr {![catch {expr {$str}}]}]
  421. }
  422.  
  423. proc is::Integer {str1} {
  424.     return [regexp {^(\+|-)?[0-9]+$} [string trim $str1]]
  425. }
  426.  
  427. proc is::UnsignedInteger {str1} {
  428.     return [regexp {^[0-9]+$} [string trim $str1]]
  429. }
  430.  
  431. proc is::PositiveInteger {str1} {
  432.     if {[is::UnsignedInteger $str1]} {
  433.     return [expr {$str1 > 0}]
  434.     }
  435.     return 0
  436. }
  437.  
  438. # Takes any string and tests whether or not that string contains all 
  439. # whitespace characters.  Carriage returns are considered whitespace, 
  440. # as are spaces and tabs.  Also returns true for the null string.
  441. proc is::Whitespace {anyString} {
  442.     return [regexp "^\[ \t\r\n\]*$" $anyString]
  443. }
  444.  
  445.  
  446. ###########################################################################
  447. #  Parse a string into "word"s, which include blocks of non-space text,
  448. #  double- and single-quoted strings, and blocks of text enclosed in 
  449. #  balanced parentheses or curly brackets.
  450. #
  451. #  If a word is delimited by a quote or paren character (\", \', \(, or \{),
  452. #  then _that_ particular delimiter may be included within the word if it is 
  453. #  backslash-quoted, as above.  No other characters are special or need quoting
  454. #  with that word.  The quoted delimiters are unquoted in the list of words 
  455. #  returned.  
  456. #
  457. proc parseWords {entry} {
  458.     set slash "\\"
  459.     set qslash "\\\\"
  460.     
  461.     set words {}
  462.     set entry [string trim $entry]
  463.     
  464.     while {[string length $entry]} {
  465.     set delim [string range $entry 0 0]
  466.     set entry [string range $entry 1 end]
  467.     
  468.     #        regexp $endPat   matches the end of the word
  469.     #               $openPat  matches the open delimiter
  470.     #               $unescPat matches escaped instances of the open/close delimiters
  471.     #
  472.     #        $type == "quote" means open/close delimiters are the same
  473.     #              == "paren" means there's a close delimiter and nesting is possible
  474.     #              == "unquoted" means the word is delimited by whitespace.
  475.     #
  476.     if {$delim == {"}} {            
  477.         set endPat {^([^"]*)"}
  478.         set unescPat {\\(")}
  479.         set type quote
  480.         
  481.     } elseif {$delim == {'}} {        
  482.         set endPat {^([^']*)'}
  483.         set unescPat {\\(')}
  484.         set type quote
  485.         
  486.     } elseif {$delim == "\{"} {        
  487.         set endPat "^(\[^\}\]*)\}"
  488.         set openPat "\{"
  489.         set unescPat "\\\\(\[\{\}\])"
  490.         set type paren
  491.         
  492.     } elseif {$delim == "("} {        
  493.         set endPat {^([^)]*)\)}
  494.         set openPat {(}
  495.         set unescPat {\\([()])}
  496.         set type paren
  497.         
  498.     } else {                        
  499.         set type unquoted
  500.     }
  501.     
  502.     if {$type == "quote"} {
  503.         set ck $qslash
  504.         set fld ""
  505.         while {$ck == $qslash} {
  506.         set ok [regexp -indices -- $endPat $entry mtch sub1]
  507.         if {$ok} {
  508.             append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  509.             set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  510.             set pos [expr {1 + [lindex $mtch 1]}]
  511.             set entry [string range $entry $pos end]
  512.         } else {
  513.             error "Couldn't match $delim as field delimiter"
  514.         }
  515.         }
  516.         set pos [expr {[string length $fld] - 2}]
  517.         set fld [string range $fld 0 $pos]
  518.         regsub -all -- $unescPat $fld {\1} fld
  519.         
  520.     } elseif {$type == "paren"} {
  521.         
  522.         set nopen 1
  523.         set nclose 0
  524.         set fld ""
  525.         while {$nopen - $nclose != 0} {
  526.         set ok [regexp -indices -- $endPat $entry mtch sub1]
  527.         if {$ok} {
  528.             append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  529.             set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  530.             set entry [string range $entry [expr {1 + [lindex $mtch 1]}] end]
  531.             regsub -all -- $unescPat $fld {} fld1
  532.             set nopen [llength [split $fld1 $openPat]]
  533.             if {$ck != $qslash} { incr nclose }
  534.         } else {
  535.             error "Couldn't match $delim as field delimiter"
  536.         } 
  537.         }
  538.         set pos [expr {[string length $fld] - 2}]
  539.         set fld [string range $fld 0 $pos]
  540.         regsub -all -- $unescPat $fld {\1} fld
  541.         
  542.     } elseif {$type == "unquoted"} {
  543.         
  544.         set entry ${delim}${entry}
  545.         set ok [regexp -indices {^([^     ]*)} $entry mtch sub1]
  546.         if {$ok} {
  547.         set fld [string range $entry [lindex $sub1 0] [lindex $sub1 1]]
  548.         set pos [expr {1 + [lindex $mtch 1]}]
  549.         set entry [string range $entry $pos end]
  550.         } else {
  551.         set fld ""
  552.         set entry ""
  553.         }
  554.     } else {
  555.         error "parseWords: unrecognized case"
  556.     }
  557.     
  558.     lappend words $fld
  559.     set entry [string trimleft $entry]
  560.     }
  561.     return $words
  562. }
  563.  
  564.